;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021 Zheng Junjie <873216071@qq.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix scripts locate)
  #:use-module (guix ui)
  #:use-module (guix scripts)
  #:use-module (guix scripts build)
  #:autoload   (guix import json) (json->scheme-file)
  #:use-module (guix grafts)
  #:use-module (guix diagnostics)
  #:use-module ((guix scripts archive) #:select (options->derivations+files))
  #:use-module (guix store)
  #:use-module (guix transformations)
  #:use-module (guix monads)
  #:use-module (guix modules)
  #:use-module (guix combinators)
  #:use-module (guix packages)
  #:use-module (guix derivations)
  #:use-module (guix gexp)
  #:use-module ((guix status) #:select (with-status-verbosity))
  #:use-module (gnu packages)
  #:use-module (gnu packages base)
  #:use-module (gnu packages emacs)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-37)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:export (guix-locate))

(define (show-help)
  (display (G_ "Usage: guix locate [OPTION]... PACKAGE|STORE-ITEM
search the file of the PACKAGE or STORE-ITEM.\n"))
  (display (G_ "
      --substitute-urls=URLS
                         fetch substitute from URLS if they are authorized"))
  (display (G_ "
  -r  --regex
                         use regex"))
  (newline)
  (display (G_ "
  -s, --system=SYSTEM    consider packages for SYSTEM--e.g., \"i686-linux\""))
  (newline)
  (display (G_ "
  -L, --load-path=DIR    prepend DIR to the package module search path"))
  (newline)
  (display (G_ "
  -h, --help             display this help and exit"))
  (display (G_ "
  -V, --version          display version information and exit"))
  (newline)
  (show-bug-report-information))

(define %options
  ;; Specifications of the command-line options.
  (list (option '(#\b "basename") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'basename arg result)))
        (option '(#\s "system") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'system arg
                              (alist-delete 'system result eq?))))
        (option '("search") #t #t
                (lambda (opt name arg result)
                  (alist-cons 'query arg
                              result)))
        (option '(#\n "dry-run") #f #f
                (lambda (opt name arg result)
                  (alist-cons 'dry-run? #t result)))
        (option '("no-substitutes") #f #f
                (lambda (opt name arg result . rest)
                  (apply values
                         (alist-cons 'substitutes? #f
                                     (alist-delete 'substitutes? result))
                         rest)))
        (option '(#\r "regex") #f #f
                (lambda (opt name arg result)
                  (alist-cons 'regex? #t result)))
        (option '("regextype") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'regextype arg result)))
        (option '("findoptions") #t #f
                (lambda (opt name arg result . rest)
                  (apply values
                         (alist-cons 'findoptions
                                     (string-tokenize arg)
                                     result )
                         rest)))
        (option '(#\l "limit") #t #f
                (lambda (opt name arg result)
                  (alist-cons 'limit arg result)))
        (option '("substitute-urls") #t #f
                (lambda (opt name arg result . rest)
                  (apply values
                         (alist-cons 'substitute-urls
                                     (string-tokenize arg)
                                     (alist-delete 'substitute-urls result))
                         rest)))
        (find (lambda (option)
                (member "load-path" (option-names option)))
              %standard-build-options)
        (option '(#\h "help") #f #f
                (lambda _
                  (show-help)
                  (exit 0)))
        (option '(#\V "version") #f #f
                (lambda _
                  (show-version-and-exit "guix locate")))))

(define %default-options
  `((system . ,(%current-system))
    (substitutes? . #t)
    (offload? . #t)
    (print-build-trace? . #t)
    (print-extended-build-trace? . #t)
    (multiplexed-build-output? . #t)
    (debug . 0)
    (verbosity . 1)))

(define* (locatedb-builder p #:key (findoptions '()))
  (with-imported-modules (source-module-closure
                          '((guix build utils)))
    #~(begin
        (use-modules (guix build utils))
        (setenv "PATH"
                (string-append
                 #+sed "/bin"
                 ":" #+coreutils-minimal "/bin"))
        (apply invoke
               (string-append #+findutils "/bin/updatedb")
               (string-append "--output=" #$output)
               (string-append "--localpaths=" #+p
                              )
               (if (null? (list #$@findoptions))
                   (list (string-append
                          "--findoptions=" "'"
                          (string-join (list #$@findoptions))
                          "'"))
                   '())))))

(define-command (guix-locate . args)
  (category packaging)
  (synopsis "locate packages or derivations without installing them")
  (define opts
    (let*-values (((args extra) (break (cut string=? "--" <>)
                                       args)))
      (let ((opts (parse-command-line
                   args
                   %options (list %default-options))))
        (unless (assoc-ref opts 'query)
          (leave (G_ "need a search args: --search=~%")))
        (match extra
          (() opts)
          (("--") opts)
          (("--" extra-option ...)
           (alist-cons 'extra-option extra-option opts))))))
  (with-error-handling
    (let* ((dry-run? (assoc-ref opts 'dry-run?))
           (verbosity (assoc-ref opts 'verbosity))
           (substitutes? (assoc-ref opts 'substitutes?))
           (system (assoc-ref opts 'system))
           (query (assoc-ref opts 'query))
           (regex? (assoc-ref opts 'regex?))
           (regextype (assoc-ref opts 'regextype))
           (findoptions (assoc-ref opts 'findoptions))
           (extra-option (assoc-ref opts 'extra-option))
           (basename (assoc-ref opts 'basename))
           (limit (assoc-ref opts 'limit)))
      (with-store store
        (with-status-verbosity verbosity
          (set-build-options-from-command-line store opts)
          (with-build-handler (build-notifier
                               #:dry-run?
                               dry-run?
                               #:verbosity
                               verbosity
                               #:use-substitutes?
                               substitutes?)
            (run-with-store store
              (mlet* %store-monad
                  ((locatedb-drvs
                    (mapm %store-monad
                          (lambda (p)
                            (gexp->derivation
                                "locatedb"
                              (locatedb-builder
                               p
                               #:findoptions (or findoptions '()))))

                          (filter-map (match-lambda
                                        (('argument . (? string? spec))
                                         ;; If FILE is a .drv that's not in
                                         ;; store, keep it so that it can be
                                         ;; substituted.
                                         (cond ((derivation-path? spec)
                                                (catch 'system-error
                                                  (lambda ()
                                                    ;; Ask for absolute file names so that .drv file
                                                    ;; names passed from the user to 'read-derivation'
                                                    ;; are absolute when it returns.
                                                    (let ((spec (canonicalize-path spec)))
                                                      (read-derivation-from-file spec)))
                                                  (lambda args
                                                    ;; Non-existent .drv files can be substituted down
                                                    ;; the road, so don't error out.
                                                    (if (= ENOENT (system-error-errno args))
                                                        #f
                                                        (apply throw args)))))
                                               ((store-path? spec)
                                                (direct-store-path spec))
                                               (else
                                                (specification->package+output spec))))
                                        (_ #f))
                                      opts)))
                   (findutils-drv (package->derivation findutils)))
                (mbegin %store-monad

                  (maybe-build
                   (cons
                    findutils-drv
                    locatedb-drvs)
                   #:dry-run? dry-run?
                   ;; usually not have substitutes, so don't use.
                   #:use-substitutes? #f)
                  (return
                   (unless dry-run?
                     (apply system* (string-append
                                     (derivation->output-path
                                      findutils-drv)
                                     "/bin/locate")
                            (string-append "--database="
                                           (string-join (map derivation->output-path locatedb-drvs) ":"))

                            query
                            `(,@(if basename
                                    (list "-b" basename)
                                    '())

                              ,@(if regex?
                                    (list "-r")
                                    '())
                              ,@(if (and regex? regextype)
                                    (list (string-append "--regextype=" regextype))
                                    '())
                              ,@(if limit
                                    (list "-l" limit)
                                    '())
                              ,@(if extra-option
                                    extra-option
                                    '())))))))
              #:system system)))))))
